#include "mlisp.h"
#include "sexp.h"
#include "gc.h"
#include "stream.h"
#include "vm.h"
#include <stdio.h>
#include <stdlib.h>		// for exit
#include <string.h>

#ifndef _MSC_VER
#include <alloca.h>
#else
#include <malloc.h>
#endif

#ifndef	FALSE
#define	FALSE	(0)
#define	TRUE	(1)
#endif

FileStream fsstdin;
FileStream fsstdout;
FileStream fsstderr;
StreamBase* sstdin;
StreamBase* sstdout;
StreamBase* sstderr;


static SExp subr_cons(int s, int argnum) {
	SExp a = vm_stack_ref(s, 0);
	SExp d = vm_stack_ref(s, 1);
	return cons(a, d);
}

static SExp subr_car(int s, int argnum) {
	SExp ss = vm_stack_ref(s, 0);
	return CAR(ss);
}

static SExp subr_cdr(int s, int argnum) {
	SExp ss = vm_stack_ref(s, 0);
	return CDR(ss);
}

static SExp subr_eq(int s, int argnum) {
	SExp a = vm_stack_ref(s, 0);
	SExp d = vm_stack_ref(s, 1);
	return eq(a, d) ? sTRUE : sFALSE;
}

static SExp subr_plus(int s, int argnum) {
	SFixnum res = 0;
	int i;
	for (i = 0; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		res += S2FIXNUM(v);
	}
	return fixnum2s(res);
}

static SExp subr_difference(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	if (argnum <= 1) {
		return fixnum2s(-res);
	} else {
		int i;
		for (i = 1; i < argnum; ++i) {
			SExp v = vm_stack_ref(s, i);
			res -= S2FIXNUM(v);
		}
		return fixnum2s(res);
	}
}

static SExp subr_times(int s, int argnum) {
	SFixnum res = 1;
	int i;
	for (i = 0; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		res *= S2FIXNUM(v);
	}
	return fixnum2s(res);
}

static SExp subr_quotient(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	if (argnum <= 1) {
		return fixnum2s(1 / res);
	} else {
		int i;
		for (i = 1; i < argnum; ++i) {
			SExp v = vm_stack_ref(s, i);
			res /= S2FIXNUM(v);
		}
		return fixnum2s(res);
	}
}

static SExp subr_numequal(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	int i;
	for (i = 1; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		SFixnum iv = S2FIXNUM(v);
		if (res == iv) {
//			res = iv;
		} else {
			return sFALSE;
		}
	}
	return sTRUE;
}

static SExp subr_numnoteq(int s, int argnum) {
	int i, j;
	for (i = 1; i < argnum; ++i) {
		SExp v1 = vm_stack_ref(s, i);
		SFixnum iv1 = S2FIXNUM(v1);
		for (j = i; --j >= 0; ) {
			SExp v0 = vm_stack_ref(s, j);
			SFixnum iv0 = S2FIXNUM(v0);
			if (iv0 == iv1) {
				return sFALSE;
			}
		}
	}
	return sTRUE;
}

static SExp subr_lessthan(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	int i;
	for (i = 1; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		SFixnum iv = S2FIXNUM(v);
		if (res < iv) {
			res = iv;
		} else {
			return sFALSE;
		}
	}
	return sTRUE;
}

static SExp subr_greaterthan(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	int i;
	for (i = 1; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		SFixnum iv = S2FIXNUM(v);
		if (res > iv) {
			res = iv;
		} else {
			return sFALSE;
		}
	}
	return sTRUE;
}

static SExp subr_lessequal(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	int i;
	for (i = 1; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		SFixnum iv = S2FIXNUM(v);
		if (res <= iv) {
			res = iv;
		} else {
			return sFALSE;
		}
	}
	return sTRUE;
}

static SExp subr_greaterequal(int s, int argnum) {
	SFixnum res = S2FIXNUM(vm_stack_ref(s, 0));
	int i;
	for (i = 1; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		SFixnum iv = S2FIXNUM(v);
		if (res >= iv) {
			res = iv;
		} else {
			return sFALSE;
		}
	}
	return sTRUE;
}

static SExp subr_logand(int s, int argnum) {
	SFixnum res;
	if (argnum == 0) {
		res = 0;
	} else {
		int i;
		res = S2FIXNUM(vm_stack_ref(s, 0));
		for (i = 1; i < argnum; ++i) {
			SExp v = vm_stack_ref(s, i);
			res &= S2FIXNUM(v);
		}
	}
	return fixnum2s(res);
}

static SExp subr_logior(int s, int argnum) {
	SFixnum res = 0;
	int i;
	for (i = 0; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		res |= S2FIXNUM(v);
	}
	return fixnum2s(res);
}

static SExp subr_logxor(int s, int argnum) {
	SFixnum res = 0;
	int i;
	for (i = 0; i < argnum; ++i) {
		SExp v = vm_stack_ref(s, i);
		res ^= S2FIXNUM(v);
	}
	return fixnum2s(res);
}

static SExp subr_lognot(int s, int argnum) {
	SExp v = vm_stack_ref(s, 0);
	return fixnum2s(~S2FIXNUM(v));
}

static SExp subr_ash(int s, int argnum) {
	SFixnum n = S2FIXNUM(vm_stack_ref(s, 0));
	SFixnum count = S2FIXNUM(vm_stack_ref(s, 1));
	if (count >= 0) {
		return fixnum2s(n << count);
	} else {
		return fixnum2s(n >> -count);
	}
}

static SExp subr_null(int s, int argnum) {
	SExp ls = vm_stack_ref(s, 0);
	return nullp(ls) ? sTRUE : sFALSE;
}

static SExp subr_pair(int s, int argnum) {
	SExp v = vm_stack_ref(s, 0);
	return consp(v) ? sTRUE : sFALSE;
}

static SExp subr_symbolp(int s, int argnum) {
	SExp v = vm_stack_ref(s, 0);
	return symbolp(v) ? sTRUE : sFALSE;
}

static SExp subr_intern(int s, int argnum) {
	SExp v = type_check(vm_stack_ref(s, 0), &TString);
	return intern(S2CSTR(v));
}

static SExp subr_gensym(int s, int argnum) {
	return gensym();
}

static SExp subr_set_car(int s, int argnum) {
	SExp cell = type_check(vm_stack_ref(s, 0), &TCell);
	SExp v = vm_stack_ref(s, 1);
	rplaca(cell, v);
	return sUNDEF;
}

static SExp subr_set_cdr(int s, int argnum) {
	SExp cell = type_check(vm_stack_ref(s, 0), &TCell);
	SExp v = vm_stack_ref(s, 1);
	rplacd(cell, v);
	return sUNDEF;
}

static SExp subr_list(int s, int argnum) {
	SExp res = sNIL;
	int i;
	for (i = argnum; --i >= 0; ) {
		SExp v = vm_stack_ref(s, i);
		res = cons(v, res);
	}
	return res;
}

static SExp append2(SExp s1, SExp s2) {
	if (consp(s1)) {
		return cons(CAR(s1), append2(CDR(s1), s2));
	} else {
		return s2;
	}
}

static SExp subr_append(int s, int argnum) {
	SExp res = sNIL;
	int i;
	for (i = argnum; --i >= 0; ) {
		SExp v = vm_stack_ref(s, i);
		if (!nullp(v)) {
			res = append2(v, res);
		}
	}
	return res;
}

static SExp subr_write(int s, int argnum) {
	SExp r = vm_stack_ref(s, 0);
	StreamBase* strm = sstdout;
	if (argnum >= 2) {
		SExp p = type_check(vm_stack_ref(s, 1), &TPort);
		strm = p.port->strm;
	}
	swrite(r, TRUE, strm);
	return sUNDEF;
}

static SExp subr_display(int s, int argnum) {
	SExp r = vm_stack_ref(s, 0);
	StreamBase* strm = sstdout;
	if (argnum >= 2) {
		SExp p = type_check(vm_stack_ref(s, 1), &TPort);
		strm = p.port->strm;
	}
	swrite(r, FALSE, strm);
	return sUNDEF;
}

static SExp subr_newline(int s, int argnum) {
	StreamBase* strm = sstdout;
	if (argnum >= 2) {
		SExp p = type_check(vm_stack_ref(s, 0), &TPort);
		strm = p.port->strm;
	}
	strm_puts(strm, "\n", 0);
	return sUNDEF;
}

static SExp subr_flush(int s, int argnum) {
	StreamBase* strm = sstdout;
	if (argnum >= 2) {
		SExp p = type_check(vm_stack_ref(s, 0), &TPort);
		strm = p.port->strm;
	}
	(strm->vtbl->flush)(strm);
	return sUNDEF;
}

static SExp subr_read(int s, int argnum) {
	StreamBase* strm = sstdin;
	if (argnum >= 1) {
		SExp p = type_check(vm_stack_ref(s, 0), &TPort);
		strm = p.port->strm;
	}
	return sread(strm);
}

static SExp subr_read_from_string(int s, int argnum) {
	const char* str = S2CSTR(vm_stack_ref(s, 0));
	StringStream* ss = (StringStream*)smalloc(sizeof(*ss), FALSE);
	StreamBase* strm = make_string_stream(ss, str, strlen(str));
	return sread(strm);
}

static SExp subr_run(int s, int argnum) {
	SExp code = vm_stack_ref(s, 0);
	return run(code, s);
}

static SExp subr_apply(int s, int argnum) {
	SExp f = vm_stack_ref(s, 0);
	int n = 0;
	SExp* args = NULL;
	if (argnum > 1) {
		SExp last = vm_stack_ref(s, argnum-1);
		SExp *pp;
		int i;
		n = length(last) + argnum - 2;
		args = (SExp*)alloca(sizeof(*args) * n);
		for (i=0, pp=args; i < argnum-2; ++i) {
			*pp++ = vm_stack_ref(s, i+1);
		}
		for (; consp(last); last = CDR(last)) {
			*pp++ = CAR(last);
		}
	}
	return apply(f, s, n, args);
}

static SExp subr_error(int s, int argnum) {
	int i;
	fputs("error: ", stderr);
	for (i=0; i<argnum; ++i) {
		swrite(vm_stack_ref(s, i), TRUE, sstderr);
	}
	fputs("\n", stderr);
	exit(1);
	return sUNDEF;
}

static SExp subr_global_variable_boundp(int s, int argnum) {
	SExp x = vm_stack_ref(s, 0);
	return eq(refer_global(x), sUNDEF) ? sFALSE : sTRUE;
}

static SExp subr_global_variable_ref(int s, int argnum) {
	SExp x = vm_stack_ref(s, 0);
	SExp res = refer_global(x);
	if (eq(res, sUNDEF)) {
		res = error("unbound variable:", x);
	}
	return res;
}

static SExp subr_primitive_functionp(int s, int argnum) {
	SExp f = vm_stack_ref(s, 0);
	return type_of(f) == &TFunction ? sTRUE : sFALSE;
}

static SExp subr_open_input_file(int s, int argnum) {
	SExp fn;
	FILE* fp;
	FileStream* fs;
	StreamBase* sb;

	fn = type_check(vm_stack_ref(s, 0), &TString);
	fp = fopen(S2CSTR(fn), "r");
	if (fp == NULL) {
		return error("Can't open %s", S2CSTR(fn));
	}

	fs = smalloc(sizeof(FileStream*), TRUE);
	sb = make_file_stream(fs, fp);
	return gen_port(sb);
}

static SExp subr_eof_objectp(int s, int argnum) {
	SExp o = vm_stack_ref(s, 0);
	return eq(o, sEOF) ? sTRUE : sFALSE;
}

static SExp subr_make_hash_table(int s, int argnum) {
	return make_hash_table();
}

static SExp subr_hash_table_put(int s, int argnum) {
	SExp ht = vm_stack_ref(s, 0);
	SExp key = vm_stack_ref(s, 1);
 	SExp val = vm_stack_ref(s, 2);
	hash_table_put(ht, key, val);
	return sUNDEF;
}

static SExp subr_hash_table_exists(int s, int argnum) {
	SExp ht = vm_stack_ref(s, 0);
	SExp key = vm_stack_ref(s, 1);
	return hash_table_exists(ht, key) ? sTRUE : sFALSE;
}

static SExp subr_hash_table_get(int s, int argnum) {
	SExp ht = vm_stack_ref(s, 0);
	SExp key = vm_stack_ref(s, 1);
	return hash_table_get(ht, key);
}

static SExp subr_hash_table_for_each(int s, int argnum) {
	SExp ht_ = type_check(vm_stack_ref(s, 0), &TSHash);
	SExp proc = vm_stack_ref(s, 1);
	HashTable* ht = &ht_.hash->ht;
	HashIterator it;
	HashEntry* p;
	for (p = ht_begin(&it, ht); p != NULL; p = ht_next(&it)) {
		SExp args[2];
		args[0] = ptr2s(p->key);
		args[1] = ptr2s(p->val);
		apply(proc, s, 2, args);
	}
	return sUNDEF;
}

static SExp subr_hash_table_keys(int s, int argnum) {
	SExp ht_ = type_check(vm_stack_ref(s, 0), &TSHash);
	HashTable* ht = &ht_.hash->ht;
	HashIterator it;
	HashEntry* p;
	SExp r = sNIL;
	for (p = ht_begin(&it, ht); p != NULL; p = ht_next(&it)) {
		SExp key = ptr2s(p->key);
		r = cons(key, r);
	}
	return r;
}

static SExp subr_hash_table_values(int s, int argnum) {
	SExp ht_ = type_check(vm_stack_ref(s, 0), &TSHash);
	HashTable* ht = &ht_.hash->ht;
	HashIterator it;
	HashEntry* p;
	SExp r = sNIL;
	for (p = ht_begin(&it, ht); p != NULL; p = ht_next(&it)) {
		SExp val = ptr2s(p->val);
		r = cons(val, r);
	}
	return r;
}

static SExp subr_hash_table_clear(int s, int argnum) {
	SExp ht_ = type_check(vm_stack_ref(s, 0), &TSHash);
	HashTable* ht = &ht_.hash->ht;
	ht_clear_all(ht);
	return sUNDEF;
}


static SExp subr_not(int s, int argnum) {
	SExp x = vm_stack_ref(s, 0);
	return (eq(x, sFALSE)) ? sTRUE : sFALSE;
}



void term_mlisp(void) {
	close_stream(sstderr);	sstderr = NULL;
	close_stream(sstdout);	sstdout = NULL;
	close_stream(sstdin);	sstdin = NULL;
}

void init_mlisp(void) {
	GC_INIT();

	init_symbol_table();
	VM_init();
#if 0
	// Common lisp mode
	sNIL = sFALSE = sUNDEF = intern("nil");
	sTRUE = intern("t");

	assign_global(sNIL, sNIL);
	assign_global(sTRUE, sTRUE);
#endif

	sstdin = make_file_stream(&fsstdin, stdin);
	sstdout = make_file_stream(&fsstdout, stdout);
	sstderr = make_file_stream(&fsstderr, stderr);

	{
		struct {
			const char* name;
			VMFunctionType func;
			int minargnum, maxargnum;
		} static const tbl[] = {
			{	"cons",					subr_cons,					2, 2,	},
			{	"car",					subr_car,					1, 1,	},
			{	"cdr",					subr_cdr,					1, 1,	},
			{	"eq?",					subr_eq,					2, 2,	},
			{	"+",					subr_plus,					0, -1,	},
			{	"-",					subr_difference,			1, -1,	},
			{	"*",					subr_times,					0, -1,	},
			{	"/",					subr_quotient,				1, -1,	},
			{	"=",					subr_numequal,				0, -1,	},
			{	"/=",					subr_numnoteq,				0, -1,	},
			{	"<",					subr_lessthan,				2, -1,	},
			{	">",					subr_greaterthan,			2, -1,	},
			{	"<=",					subr_lessequal,				2, -1,	},
			{	">=",					subr_greaterequal,			2, -1,	},
			{	"null?",				subr_null,					1, 1,	},
			{	"pair?",				subr_pair,					1, 1,	},
			{	"symbol?",				subr_symbolp,				1, 1,	},
			{	"intern",				subr_intern,				1, 1,	},
			{	"gensym",				subr_gensym,				0, 0,	},
			{	"set-car!",				subr_set_car,				2, 2,	},
			{	"set-cdr!",				subr_set_cdr,				2, 2,	},
			{	"list",					subr_list,					0, -1,	},
			{	"append",				subr_append,				0, -1,	},
			{	"write",				subr_write,					1, 2,	},
			{	"display",				subr_display,				1, 2,	},
			{	"newline",				subr_newline,				0, 1,	},
			{	"flush",				subr_flush,					0, 1,	},
			{	"read",					subr_read,					0, 1,	},
			{	"read-from-string",		subr_read_from_string,		1, 1,	},
			{	"run",					subr_run,					1, 1,	},
			{	"apply",				subr_apply,					1, -1,	},
			{	"error",				subr_error,					0, -1,	},

			{	"logand",				subr_logand,				0, -1,	},
			{	"logior",				subr_logior,				0, -1,	},
			{	"logxor",				subr_logxor,				0, -1,	},
			{	"lognot",				subr_lognot,				1, 1,	},
			{	"ash",					subr_ash,					2, 2,	},

			{	"global-variable-bound?",	subr_global_variable_boundp,	1, 1,	},
			{	"global-variable-ref",		subr_global_variable_ref,		1, 1,	},

			{	"primitive-function?",	subr_primitive_functionp,	1, 1,	},

			{	"open-input-file",		subr_open_input_file,		1, 1,	},
			{	"eof-object?",			subr_eof_objectp,			1, 1,	},

			{	"make-hash-table",		subr_make_hash_table,		0, 0,	},
			{	"hash-table-put!",		subr_hash_table_put,		3, 3,	},
			{	"hash-table-exists?",	subr_hash_table_exists,		2, 2,	},
			{	"hash-table-get",		subr_hash_table_get,		2, 2,	},
			{	"hash-table-for-each",	subr_hash_table_for_each,	2, 2,	},
			{	"hash-table-keys",		subr_hash_table_keys,		1, 1,	},
			{	"hash-table-values",	subr_hash_table_values,		1, 1,	},
			{	"hash-table-clear!",	subr_hash_table_clear,		1, 1,	},


			{	"not",					subr_not,					1, 1,	},
		};
		int i;
	
		for (i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
			SExp sym = intern(tbl[i].name);
			SExp func = gen_prim_func(tbl[i].func, tbl[i].minargnum, tbl[i].maxargnum, tbl[i].name);
			assign_global(sym, func);
		}
	}
}


SExp load_fasl(const char* fn) {
	FILE* fp = fopen(fn, "r");
	if (fp == NULL) {
		fprintf(stderr, "Can't open: %s\n", fn);
		return sUNDEF;
	} else {
		FileStream fs;
		StreamBase* strm = make_file_stream(&fs, fp);
		SExp r = sUNDEF;
		for (;;) {
			SExp code = sread(strm);
			if (eq(code, sEOF)) {
				break;
			}
			r = run(code, 0);
		}
		close_stream(strm);
		fclose(fp);
		return r;
	}
}
